home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / edit-text.lisp < prev    next >
Encoding:
Text File  |  1991-07-16  |  36.1 KB  |  1,002 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                             AUSTIN, TEXAS 78714-9149                             |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1990, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. (in-package "CLIO-OPEN")
  22.  
  23. (export '(
  24.       edit-text
  25.       edit-text-clear
  26.       edit-text-cut
  27.       edit-text-field
  28.       edit-text-grow
  29.       edit-text-field-length
  30.       edit-text-paste
  31.  
  32.       make-edit-text
  33.       make-edit-text-field
  34.       )
  35.     'clio-open)
  36.  
  37.  
  38. (defmacro char-or-keysym (keysym)
  39.   ;; Expands to the character corresponding to the KEYSYM in the
  40.   ;; default global (display-independent) keysym mapping, if any.
  41.   ;; Otherwise, expands to the KEYSYM.
  42.   (let ((mapping (find-if #'(lambda (mapping)
  43.                   ;; Better to use keysym-mapping accessors directly, but in R3 CLX these
  44.                   ;; macros are defined only at compile time. 
  45.                   (and (characterp (first mapping))               ; xlib::keysym-mapping-object 
  46.                    (not (second mapping))               ; xlib::keysym-mapping-mask 
  47.                    (not (third mapping))               ; xlib::keysym-mapping-modifiers 
  48.                    (not (fourth mapping))               ; xlib::keysym-mapping-lowercase 
  49.                    (not (fifth mapping))               ; xlib::keysym-mapping-translate 
  50.                    ))
  51.               
  52.               (gethash keysym xlib::*keysym->character-map*))))
  53.     `,(if mapping
  54.     (first mapping)                                   ; xlib::keysym-mapping-object 
  55.     keysym)))
  56.  
  57.  
  58.  
  59. (defconstant
  60.   *default-edit-text-field-command-table*
  61.   (make-text-command-table
  62.     :default                                 'text-insert
  63.     #\rubout                                 'text-rubout
  64.     #\newline                                'text-complete
  65.     #\linefeed                               'text-complete
  66.     (char-or-keysym #.(xlib::keysym 255 83)) '(text-move-point :chars 1)       ; Right Arrow
  67.     (char-or-keysym #.(xlib::keysym 255 81)) '(text-move-point :chars -1)      ; Left Arrow 
  68.     (char-or-keysym #.(xlib::keysym 255 82)) 'ignore                   ; Up Arrow
  69.     (char-or-keysym #.(xlib::keysym 255 84)) 'ignore                   ; Down Arrow
  70.  
  71.     ;; KCL doesn't support char-bits!
  72.     #-kcl #\Control-\y                       #-kcl 'edit-text-paste
  73.     #-kcl #\Control-\w                       #-kcl 'edit-text-cut
  74.     #-kcl #\Meta-\w                          #-kcl 'display-text-copy
  75.     #-kcl #\Control-\a                       #-kcl '(text-move-sol)
  76.     #-kcl #\Control-\e                       #-kcl '(text-move-eol)
  77.     #-kcl #\Control-\k                       #-kcl '(text-delete-eol)
  78.     ))
  79.           
  80.  
  81. ;;;----------------------------------------------------------------------------+
  82. ;;;                                                                            |
  83. ;;;                                text-editor                                 |
  84. ;;;                                                                            |
  85. ;;;----------------------------------------------------------------------------+
  86.  
  87. (defconstant *i-bar-cursor-index* 152)
  88.  
  89. (defcontact text-editor ()
  90.   ((commands         :type         list
  91.              :initform       (list *default-edit-text-field-command-table*)
  92.              :initarg         :commands
  93.              :accessor         edit-text-commands)   
  94.  
  95.    (focus-p          :type           boolean
  96.              :initform       nil
  97.              :accessor       edit-text-focus-p))
  98.   
  99.   (:resources
  100.     (cursor :initform *i-bar-cursor-index* :type cursor))
  101.   
  102.   (:documentation  "Basic behaviors for editing text."))
  103.  
  104.  
  105.  
  106. ;;;----------------------------------------------------------------------------+
  107. ;;;                                                                            |
  108. ;;;                              Event Handling                                |
  109. ;;;                                                                            |
  110. ;;;----------------------------------------------------------------------------+
  111.  
  112. (defevent text-editor (:button-press :button-1 :control) edit-text-cut)
  113. (defevent text-editor :enter-notify  (change-focus t))
  114. (defevent text-editor :leave-notify  (change-focus nil))
  115. (defevent text-editor :focus-out     (change-focus nil t))
  116. (defevent text-editor :focus-in      (change-focus t t))
  117. (defevent text-editor :key-press     perform-command)
  118.  
  119. (defun change-focus (text new-value &optional explicit-p)
  120.   (with-event (focus-p kind)
  121.     (when
  122.       (and
  123.     ;; Text window actually the one gaining/losing focus?
  124.     (if explicit-p
  125.         (member kind '(:ancestor :inferior :nonlinear))     
  126.         focus-p)
  127.  
  128.     ;; Actually losing when leaving?
  129.     (or new-value explicit-p (not (eq (input-focus (contact-display text)) text))))
  130.       
  131.       (setf (edit-text-focus-p text) new-value))))
  132.  
  133.  
  134.  
  135. ;;;----------------------------------------------------------------------------+
  136. ;;;                                                                            |
  137. ;;;                                  Display                                   |
  138. ;;;                                                                            |
  139. ;;;----------------------------------------------------------------------------+
  140.  
  141.  
  142.  
  143. (defmethod (setf text-caret-displayed-p) (boolean (text text-editor)
  144.                       &optional exposed-x exposed-y exposed-width exposed-height)
  145.   (unless (or (not (realized-p text)) (text-selection-range text))
  146.     (with-slots (focus-p point foreground) text
  147.       (let*
  148.     ((scale  (contact-scale text))
  149.      (caret  (getf *text-caret-dimensions* scale))
  150.      (offset (text-caret-baseline-offset caret)))
  151.     
  152.     ;; Get image and dimensions for active/inactive caret.
  153.     (multiple-value-bind (width height image)
  154.         (if focus-p
  155.         (values
  156.           (text-caret-width caret)
  157.           (text-caret-height caret)        
  158.           (getf (getf *text-caret-images* :active) scale))
  159.         
  160.         (values
  161.           nil
  162.           (or (text-caret-inactive-height caret) (text-caret-height caret))        
  163.           (getf (getf *text-caret-images* :inactive) scale)))
  164.       
  165.       ;; Adjust amount of image to copy.
  166.       (setf width  (or width height)
  167.         height (min height (+ (text-caret-descent text scale) offset)))
  168.       
  169.       ;; Copy image pixmap.
  170.       (multiple-value-bind (x y) (text-base-position text point)
  171.         (using-gcontext (gc :drawable text :function boole-xor :exposures :off)
  172.           (with-gcontext (gc :clip-mask (when exposed-x (list exposed-x exposed-y exposed-width exposed-height)))
  173.         (copy-area
  174.           (contact-image-mask
  175.             text image
  176.             :foreground (logxor foreground (contact-current-background-pixel text)))
  177.           gc
  178.           0 0 width height
  179.           text
  180.           (1+ (- x (pixel-round width 2))) (- y offset)))))))))
  181.   boolean)
  182.  
  183.  
  184. (defgeneric text-caret-descent (text scale)
  185.   (:documentation "Return the descent of the displayed caret for TEXT."))
  186.  
  187.  
  188. (defmethod text-caret-descent ((text text-editor) scale)
  189.   (let ((dimensions (getf *text-caret-dimensions* scale)))
  190.     (- (or (text-caret-inactive-height dimensions)
  191.        (text-caret-height dimensions))
  192.        (text-caret-baseline-offset dimensions))))
  193.  
  194.  
  195. (defmethod compute-text-geometry :around ((text text-editor))
  196.   (with-slots (gravity) text
  197.     (multiple-value-bind (left top width height ascent descent)
  198.     (call-next-method)
  199.       (values
  200.     ;; Leave room for caret at end.
  201.     (case gravity
  202.       ((:north-west :west :south-west)
  203.        (+ left (pixel-round (text-caret-width (getf *text-caret-dimensions* (contact-scale text))) 2)))
  204.       ((:north-east :east :south-east)
  205.        (- left (pixel-round (text-caret-width (getf *text-caret-dimensions* (contact-scale text))) 2)))
  206.       (otherwise
  207.        left))
  208.     top width height ascent descent))))
  209.  
  210.  
  211.  
  212. ;;;----------------------------------------------------------------------------+
  213. ;;;                                                                            |
  214. ;;;                                 Selection                                  |
  215. ;;;                                                                            |
  216. ;;;----------------------------------------------------------------------------+
  217.  
  218. (defgeneric edit-text-clear (text)
  219.   (:documentation "Sets the source of the TEXT to the empty string."))
  220.  
  221. (defmethod edit-text-clear ((text text-editor))
  222.   (setf (display-text-source text) ""))
  223.  
  224. (defgeneric edit-text-cut (text)
  225.   (:documentation "Causes the TEXT selection to be deleted into the :CLIPBOARD.
  226. Returns the deleted text."))
  227.  
  228. (defmethod edit-text-cut ((text text-editor))
  229.   (let ((clip (clipboard-copy text)))
  230.     (when clip (text-rubout text))
  231.     clip))
  232.  
  233. (defgeneric edit-text-paste (text)
  234.   (:documentation "Inserts the :CLIPBOARD into the TEXT and returns the inserted string."))
  235.  
  236. (defmethod edit-text-paste ((text text-editor))
  237.   (let*
  238.     ((display     (contact-display text))
  239.      (client-clip (display-clipboard-text display))
  240.      (paste       
  241.        ;; Does this client own the :CLIPBOARD selection?
  242.        (if (plusp (length client-clip))
  243.        
  244.        ;; Yes, get it the easy way.
  245.        client-clip
  246.        
  247.        ;; No, use interclient communication.
  248.        (flet
  249.          ((throw-convert (text) 
  250.                  (declare (ignore text))
  251.                  (with-event (property) (throw :convert property))))
  252.          
  253.          (let ((time (when (processing-event-p) (with-event (time) time))))
  254.            (with-event-mode (text `(:selection-notify ,#'throw-convert)) 
  255.          (convert-selection :clipboard :string text :paste time)
  256.          
  257.          ;; Wait for :selection-notify to report result of conversion.
  258.          (when (catch :convert (loop (process-next-event display)))
  259.            
  260.            ;; Conversion successful --- get stored value.
  261.            (get-property
  262.              text :paste :result-type 'string
  263.  
  264.              ;; The :string target specifies Latin-1 encoding. This happens to correspond
  265.              ;; to the keysym encoding, hence the following transform function.
  266.              ;; Note that #'code-char might work on many systems, but this is not guaranteed
  267.              ;; since Common Lisp does not specify a standard character encoding.
  268.              
  269.              :transform #'(lambda (code) (keysym->character display code))))))))))
  270.     
  271.     (if paste
  272.     (text-insert text paste)
  273.     (bell display))
  274.     paste))
  275.  
  276.  
  277. ;;;----------------------------------------------------------------------------+
  278. ;;;                                                                            |
  279. ;;;                                 Accessors                                  |
  280. ;;;                                                                            |
  281. ;;;----------------------------------------------------------------------------+
  282.  
  283. (defmethod (setf edit-text-focus-p) :around (new-value (text text-editor))
  284.   (with-slots (focus-p) text
  285.     (let* ((changed-p (if new-value (not focus-p) focus-p))
  286.        (caret-p   (and changed-p (not (text-selection-range text)))))
  287.       (when caret-p
  288.     (setf (text-caret-displayed-p text) nil))      
  289.       (call-next-method)      
  290.       (when changed-p
  291.     (when caret-p
  292.       (setf (text-caret-displayed-p text) t))
  293.     (apply-callback text (if new-value :resume :suspend)))))  
  294.   new-value)
  295.  
  296.  
  297.  
  298.  
  299. ;;;----------------------------------------------------------------------------+
  300. ;;;                                                                            |
  301. ;;;                              edit-text-field                               |
  302. ;;;                                                                            |
  303. ;;;----------------------------------------------------------------------------+
  304.  
  305. (defcontact edit-text-field (text-editor select-text display-text-field)
  306.   ((length           :type         (or null (integer 0 *))
  307.              :initform       nil
  308.              :initarg         :length
  309.              :accessor         edit-text-field-length))
  310.   
  311.   (:resources
  312.     (font :initform *default-display-text-font*)
  313.     (display-gravity :initform :west)
  314.     length)
  315.   
  316.   (:documentation  "A single line of editable text."))
  317.  
  318. (defun make-edit-text-field (&rest initargs)
  319.   (apply #'make-contact 'edit-text-field initargs))
  320.  
  321.  
  322. ;;;----------------------------------------------------------------------------+
  323. ;;;                                                                            |
  324. ;;;                                 Accessors                                  |
  325. ;;;                                                                            |
  326. ;;;----------------------------------------------------------------------------+
  327.  
  328.  
  329. (defmethod (setf edit-text-point) :before (new-point (text edit-text-field) &key clear-p)
  330.   (declare (ignore clear-p))
  331.   (check-type new-point (or null (integer 0 *))))
  332.  
  333. (defmethod (setf edit-text-mark) :before (new-mark (text edit-text-field))
  334.   (check-type new-mark (or null (integer 0 *))))
  335.  
  336.  
  337. ;;;----------------------------------------------------------------------------+
  338. ;;;                                                                            |
  339. ;;;                                  Display                                   |
  340. ;;;                                                                            |
  341. ;;;----------------------------------------------------------------------------+
  342.  
  343. (defmethod display :around ((text edit-text-field) &optional x y width height &key) 
  344.   
  345.   ;; Display underline
  346.   (multiple-value-bind (base-x base-y) (call-next-method)    
  347.     (let ((scale (contact-scale text)))
  348.       (with-slots (foreground font length width clip-rectangle) text      
  349.     (let*
  350.       ((underline-y (+ base-y (text-caret-descent text scale)))
  351.        ;; Length of line reflects max string length
  352.        (start-x     (if length
  353.                 base-x
  354.                 0))
  355.        (end-x       (if length
  356.                 (+ base-x
  357.                    (* length
  358.                   ;; Use average char width and hope for the best.
  359.                   (pixel-round (+ (min-char-width font) (max-char-width font)) 2)))
  360.                 width)))
  361.       
  362.       (using-gcontext (gc :drawable   text
  363.                   :foreground foreground
  364.                   :clip-mask  clip-rectangle)
  365.         (draw-line text gc start-x underline-y end-x underline-y))))))
  366.   
  367.   ;; Display caret, current selection
  368.   (setf (text-selection-displayed-p text x y width height) t)
  369.   (setf (text-caret-displayed-p text) t))
  370.  
  371. (defmethod text-clear-line ((text edit-text-field) base-x base-y)
  372.   (with-slots (font) text
  373.     (clear-area
  374.       text
  375.       :x      base-x
  376.       :y      (- base-y (font-ascent font))
  377.       :height (+ (font-ascent font) (text-caret-descent text (contact-scale text))))))
  378.  
  379.  
  380.  
  381. (defmethod text-change-highlight ((text edit-text-field) from to
  382.                   &optional exposed-x exposed-y exposed-width exposed-height)
  383.   (when (realized-p text)
  384.     (with-slots (font foreground clip-rectangle) text
  385.     (let ((ascent  (font-ascent font))
  386.       (descent (font-descent font)))
  387.       
  388.       (multiple-value-bind (from-x from-y)
  389.       (text-mark-point text from)
  390.     (let ((to-x (text-mark-point text to)))
  391.       
  392.       (using-gcontext
  393.         (gc :drawable   text
  394.         :function   boole-xor
  395.         :clip-mask  clip-rectangle
  396.         :foreground (logxor
  397.                   foreground
  398.                   (contact-current-background-pixel text)))                
  399.         
  400.         (if exposed-x
  401.         
  402.         ;; Clip highlight to intersection of clip rectangle and exposed region.
  403.         (let
  404.           ((old-clip-x      (display-clip-x text))
  405.            (old-clip-y      (display-clip-y text))
  406.            (old-clip-width  (display-clip-width text))
  407.            (old-clip-height (display-clip-height text)))
  408.           
  409.           (setf
  410.             (display-clip-x text)     (max old-clip-x exposed-x)
  411.             (display-clip-y text)     (max old-clip-y exposed-y)
  412.             (display-clip-width text) (- (min (+ exposed-x exposed-width)
  413.                               (+ old-clip-x old-clip-width))
  414.                          (display-clip-x text))
  415.             (display-clip-height text) (- (min (+ exposed-y exposed-height)
  416.                                (+ old-clip-y old-clip-height))
  417.                           (display-clip-y text)))
  418.           ;; Does intersection exist?
  419.           (when (and (plusp (display-clip-width text)) (plusp (display-clip-height text)))
  420.             (with-gcontext (gc :clip-mask clip-rectangle)
  421.               (draw-rectangle
  422.             text gc
  423.             (min from-x to-x) (- from-y ascent)
  424.             (abs (- from-x to-x))
  425.             (+ ascent descent)
  426.             t)))
  427.           
  428.           ;; Restore clip rectangle
  429.           (setf (display-clip-x text)      old-clip-x
  430.             (display-clip-y text)      old-clip-y
  431.             (display-clip-width text)  old-clip-width
  432.             (display-clip-height text) old-clip-height))
  433.         
  434.         ;; Else draw highlight without additional clipping
  435.         (draw-rectangle
  436.           text gc
  437.           (min from-x to-x) (- from-y ascent)
  438.           (abs (- from-x to-x))
  439.           (+ ascent descent)
  440.           t)))))))))
  441.  
  442.  
  443.  
  444.  
  445. ;;;----------------------------------------------------------------------------+
  446. ;;;                                                                            |
  447. ;;;                                   Geometry                                 |
  448. ;;;                                                                            |
  449. ;;;----------------------------------------------------------------------------+
  450.  
  451. (defmethod preferred-size ((text edit-text-field) &key width height border-width)
  452.   (with-slots
  453.     (length font (contact-width width) (contact-height height) (contact-border-width border-width))
  454.     text
  455.     (multiple-value-bind (text-width text-height) 
  456.     (if length
  457.         ;; Prefer to be big enough for length chars (use average char width and hope for the best).
  458.         (values (* length (pixel-round (+ (min-char-width font) (max-char-width font)) 2))
  459.             (+ (font-ascent font) (font-descent font)))
  460.  
  461.         ;; Else use current source extent.
  462.         (display-text-extent text))
  463.  
  464.       (let ((scale (contact-scale text)))    
  465.     (values
  466.       ;; Ensure wide enough to display caret at end.
  467.       (max (+ text-width (text-caret-width (getf *text-caret-dimensions* scale))) (or width contact-width))
  468.  
  469.       ;; Ensure tall enough to display caret and underline.
  470.       (max (+ text-height (text-caret-descent text scale) 1) (or height contact-height))
  471.       (or border-width contact-border-width))))))
  472.  
  473.  
  474. (defmethod text-caret-descent :around ((text edit-text-field) scale)
  475.   ;; Decrement normal caret height to avoid underline.
  476.   (1- (call-next-method)))
  477.  
  478.  
  479. (defmethod display-text-extent :around ((text edit-text-field))
  480.   (multiple-value-bind (width height ascent) (call-next-method)
  481.     (declare (ignore height))
  482.     (let ((descent (1+ (text-caret-descent text (contact-scale text)))))
  483.       (values width (+ ascent descent) ascent descent))))      
  484.  
  485.  
  486.  
  487. ;;;----------------------------------------------------------------------------+
  488. ;;;                                                                            |
  489. ;;;                             Command Functions                              |
  490. ;;;                                                                            |
  491. ;;;----------------------------------------------------------------------------+
  492.  
  493.  
  494. (defun perform-command (edit-text)
  495.   (with-slots (commands) edit-text
  496.     (with-event (character keysym)
  497.       (let ((input (or character keysym)))
  498.     
  499.     ;; Look up command in command table list.
  500.     (multiple-value-bind (command default)
  501.         (dolist (table commands)
  502.           (let* ((command (text-command table input))
  503.              (default (unless command (text-command table :default))))
  504.         (when (or command default)
  505.           (return (values command default)))))
  506.       
  507.       (cond
  508.         ;; Command found --- call with edit-text and other args.
  509.         (command
  510.          (if (listp command)
  511.          (apply (first command) edit-text (rest command))
  512.          (funcall command edit-text)))
  513.         
  514.         ;; Default command found --- call with edit-text, input, and other args.
  515.         (default
  516.          (if (listp default)
  517.          (apply (first default) edit-text input (rest default))
  518.          (funcall default edit-text input)))))))))
  519.  
  520.  
  521.   
  522. (defgeneric text-insert (edit-text chars)
  523.   (:documentation "Insert the CHARS into the EDIT-TEXT at the current point
  524. and increment the point."))
  525.  
  526.  
  527. (defmethod text-insert ((text text-editor) input)
  528.   ;; If input not character or string, then ignore.
  529.   ;; This case may occur for non-character keysyms like arrow keys.
  530.   (declare (ignore input)))
  531.  
  532. (defmethod text-insert :around ((text text-editor) (input character))
  533.   ;; Ignore non-graphic characters (e.g. #\Hyper-Q).
  534.   (if (graphic-char-p input)
  535.       (call-next-method)
  536.       (text-insert-nongraphic text input)))
  537.  
  538.  
  539. (defgeneric text-insert-nongraphic (text input)
  540.   (:documentation "Insert non-graphic INPUT into the EDIT-TEXT at the current point."))
  541.  
  542. (defmethod text-insert-nongraphic ((text text-editor) input)
  543.   (declare (ignore input))
  544.   (bell (contact-display text)))
  545.  
  546.  
  547.  
  548. (defmethod edit-text-field-insert ((text edit-text-field) char) 
  549.   (declare (type edit-text-field text)
  550.        (type (or character string) char))
  551.   (with-slots (buffer mark point gravity length) 
  552.     text 
  553.     (multiple-value-bind (select-start select-end) (text-selection-range text)
  554.      
  555.       ;; Invoke :insert callback
  556.       (let ((initial-insert-point (or select-start point)))
  557.     (multiple-value-bind (insert-point char)
  558.         (apply-callback-else (text :insert text initial-insert-point char)
  559.                  (values initial-insert-point char))
  560.          
  561.       (when
  562.           (or
  563.            ;; Insertion refused?
  564.            (not insert-point)
  565.          
  566.            ;; Too many chars?
  567.            (and length (>= (buffer-length buffer) length)
  568.             (bell (contact-display text)) t))
  569.            
  570.         ;; Insertion not allowed. 
  571.         (return-from edit-text-field-insert))
  572.          
  573.       ;; If insert point altered, then clear selection and do not delete it.
  574.       (unless (or (not select-start) (= insert-point initial-insert-point))
  575.         (setf (edit-text-mark text) point
  576.           select-start          nil))
  577.          
  578.       (while-changing-marks (text) 
  579.         (let* ((clear-all-p
  580.             (case gravity
  581.               ((:north-west :west :south-west) select-start)
  582.               (otherwise                       t)))
  583.            (clear-position
  584.             (if clear-all-p 0 insert-point)))
  585.          
  586.           ;; Clear before changing source.
  587.           (multiple-value-bind (base-x base-y)
  588.           (text-base-position text clear-position)
  589.         (text-clear-line text base-x base-y)
  590.            
  591.         ;; Delete current selection.
  592.         (when select-start
  593.           (buffer-delete buffer select-start select-end))
  594.            
  595.            
  596.         ;; Insert new character and move point
  597.         (let ((new-point (buffer-line-insert buffer char insert-point)))
  598.              
  599.           ;; Refresh new line
  600.           (text-refresh-line
  601.            text clear-position
  602.            :clear-p nil
  603.            :base-x  (unless clear-all-p base-x)
  604.            :base-y  base-y)           
  605.              
  606.           ;; Update point, mark.
  607.           (setf mark (setf point new-point)))))))))))
  608.  
  609. (defmethod text-insert ((text edit-text-field) (char character))
  610.   (edit-text-field-insert text char))
  611.  
  612. (defmethod text-insert ((text edit-text-field) (char string))
  613.   (edit-text-field-insert text char))
  614.  
  615.  
  616. (defgeneric text-move-point (edit-text &key lines chars)
  617.   (:documentation "Increment the point of the EDIT-TEXT by the 
  618. given number of LINES and CHARS."))
  619.  
  620. (defmethod text-move-point ((text text-editor) &key (lines 0) (chars 0))
  621.   (with-slots (point mark  buffer) text
  622.     (while-changing-marks (text)
  623.       (let ((new-point (buffer-move-mark buffer point :chars chars :lines lines)))
  624.     (if (text-selection-range text)
  625.         (text-change-highlight text point new-point)
  626.         (setf mark (move-mark mark new-point)))
  627.     (setf point (move-mark point new-point))))
  628.     
  629.     (apply-callback text :point text (buffer-mark-position buffer point))))
  630.  
  631.  
  632.  
  633. (defgeneric text-move-sol (edit-text)
  634.   (:documentation "Move to the start of the current line of EDIT-TEXT."))
  635.  
  636. (defmethod text-move-sol ((text text-editor))
  637.   (with-slots (point buffer) text
  638.     (setf (edit-text-point text :clear-p (not (text-selection-range text)))
  639.       (buffer-sol buffer point))))
  640.  
  641. (defgeneric text-move-eol (edit-text)
  642.   (:documentation "Move to the end of the current line of EDIT-TEXT."))
  643.  
  644. (defmethod text-move-eol ((text text-editor))
  645.   (with-slots (point buffer) text
  646.     (setf (edit-text-point text :clear-p (not (text-selection-range text)))
  647.       (buffer-eol buffer point))))
  648.  
  649.  
  650. (defgeneric text-delete-eol (edit-text)
  651.   (:documentation "Delete to the end of the current line of EDIT-TEXT."))
  652.  
  653. (defmethod text-delete-eol ((text text-editor))
  654.   (with-slots (point buffer) text
  655.     ;; Select to end of line...
  656.     (setf (edit-text-mark text) (buffer-eol buffer point))
  657.  
  658.     ;; ...and delete it.
  659.     (text-rubout text)))
  660.  
  661. (defgeneric text-rubout (edit-text)
  662.   (:documentation "Decrement the current point and delete the character in the EDIT-TEXT 
  663. at the new point."))
  664.  
  665.  
  666. (defmethod text-rubout ((text edit-text-field))
  667.   (with-slots (point mark gravity buffer) text
  668.     (multiple-value-bind (select-start select-end) (text-selection-range text)
  669.       
  670.       ;; Attempt to delete non-existent character?
  671.       (if (and (not select-start) point (zerop point))
  672.       
  673.       ;; Yes, beep a warning.
  674.       (bell (contact-display text))
  675.       
  676.       ;; No, perform delete.      
  677.       (let ((initial-start (or select-start (buffer-move-mark buffer point :chars -1)))
  678.         (initial-end  (or select-end point)))
  679.         
  680.         ;; Invoke :delete callback.
  681.         (multiple-value-bind (start end)
  682.         (apply-callback-else (text :delete text initial-start initial-end)
  683.           (values initial-start initial-end))
  684.           
  685.           ;; Deletion allowed?
  686.           (unless start (return-from text-rubout))
  687.           
  688.           ;; If delete range altered, then clear selection and do not delete it.
  689.           (unless (and (= start initial-start) (= end initial-end))
  690.         (setf (edit-text-mark text) point
  691.               select-start          nil))
  692.           
  693.           (let*
  694.         ((clear-all-p
  695.            (case gravity
  696.              ((:north-west :west :south-west) select-start)
  697.              (otherwise                       t)))
  698.          (clear-position
  699.            (if clear-all-p 0 start)))
  700.         
  701.         (while-changing-marks (text)
  702.           ;; Clear before changing source.
  703.           (multiple-value-bind (base-x base-y) (text-base-position text clear-position)
  704.             (text-clear-line text base-x base-y)
  705.             
  706.             ;; Delete chars and reset point, mark.
  707.             (buffer-line-delete buffer (setf point (setf mark start)) end)      
  708.             
  709.             ;; Redisplay chars    
  710.             (text-refresh-line
  711.               text clear-position
  712.               :clear-p nil
  713.               :base-x  (unless clear-all-p base-x)
  714.               :base-y  base-y))))))))))
  715.  
  716.  
  717. (defgeneric text-complete (edit-text)
  718.   (:documentation "Invoke the :complete callback."))
  719.  
  720. (defmethod text-complete ((text text-editor))
  721.   (multiple-value-bind (verified-p message)
  722.       (apply-callback-else (text :verify text)
  723.     t)
  724.  
  725.     (if verified-p
  726.     (apply-callback text :complete)
  727.     
  728.     (confirm-p
  729.       :near          text
  730.       :message       (or message "Text changes not accepted.")
  731.       :accept-only   :on))))
  732.  
  733.  
  734.  
  735. ;;;----------------------------------------------------------------------------+
  736. ;;;                                                                            |
  737. ;;;                                 edit-text                                  |
  738. ;;;                                                                            |
  739. ;;;----------------------------------------------------------------------------+
  740.  
  741. (defconstant
  742.   *default-edit-text-command-table*
  743.   (make-text-command-table
  744.     :default                                 'text-insert
  745.     #\rubout                                 'text-rubout
  746.     (char-or-keysym #.(xlib::keysym 255 83)) '(text-move-point :chars 1)   ; Right Arrow
  747.     (char-or-keysym #.(xlib::keysym 255 81)) '(text-move-point :chars -1)  ; Left Arrow
  748.     (char-or-keysym #.(xlib::keysym 255 82)) '(text-move-point :lines -1)  ; Up Arrow
  749.     (char-or-keysym #.(xlib::keysym 255 84)) '(text-move-point :lines 1)  ; Down Arrow
  750.  
  751.     ;; KCL doesn't support char-bits!
  752.     #-kcl #\Control-\y                       #-kcl 'edit-text-paste
  753.     #-kcl #\Control-\w                       #-kcl 'edit-text-cut
  754.     #-kcl #\Meta-\w                          #-kcl 'display-text-copy
  755.     #-kcl #\Control-\a                       #-kcl '(text-move-sol)
  756.     #-kcl #\Control-\e                       #-kcl '(text-move-eol)
  757.     #-kcl #\Control-\k                       #-kcl '(text-delete-eol)
  758.     ))
  759.  
  760. (defcontact edit-text (text-editor display-text)
  761.   ((commands :initform (list *default-edit-text-command-table*)))
  762.   
  763.   (:resources
  764.     (display-gravity :initform :north-west))
  765.  
  766.   
  767.   (:documentation  "Multiple lines of editable text."))
  768.  
  769. (defun make-edit-text (&rest initargs)
  770.   (apply #'make-contact 'edit-text initargs))
  771.  
  772.  
  773.  
  774.  
  775.  
  776. ;;;----------------------------------------------------------------------------+
  777. ;;;                                                                            |
  778. ;;;                             Command Functions                              |
  779. ;;;                                                                            |
  780. ;;;----------------------------------------------------------------------------+
  781.  
  782.  
  783. (let ((insert-start (make-mark)) 
  784.       (insert-mark  (make-mark)))  
  785.   (flet
  786.     ((edit-text-insert (text string)
  787.        (declare (type edit-text text)
  788.         (type (or character string) string))
  789.     
  790.        (with-slots (buffer mark point font gravity alignment extent-left extent-width) text
  791.      (multiple-value-bind (select-start select-end) (text-selection-range text)
  792.        
  793.        ;; Initialize insert mark.
  794.        (move-mark insert-start (or select-start point)) 
  795.        
  796.        ;; Invoke :insert callback, if necessary
  797.        (multiple-value-bind (insert-pos string)
  798.            (apply-callback-else
  799.          (text :insert text (buffer-mark-position buffer insert-start) string)
  800.          (values t string))
  801.          
  802.          ;; Insert allowed?
  803.          (unless insert-pos (return-from edit-text-insert))
  804.          
  805.          ;; New insert position returned?
  806.          (unless (eq insert-pos t)
  807.            ;; Yes, convert to insert mark.
  808.            (buffer-position-mark buffer insert-pos insert-start))
  809.          
  810.          ;; If insert point altered, then clear selection and do not delete it.
  811.          (unless (or (not select-start) (mark-equal insert-start select-start))
  812.            (setf (edit-text-mark text) point
  813.              select-start          nil))
  814.          
  815.          (while-changing-marks (text)
  816.            (let ((small-delete-p 
  817.                (cond
  818.              (select-start
  819.               ;; Delete current selection, if any. 
  820.               (buffer-delete buffer select-start select-end)
  821.               
  822.               ;; Return true if delete limited to one line.
  823.               (= (mark-line-index select-end) (mark-line-index select-start)))
  824.              
  825.              (:else
  826.               t))))
  827.          
  828.          ;; Insert new string and move insert mark
  829.          (move-mark insert-mark insert-start)
  830.          (buffer-insert buffer string insert-mark)
  831.          (move-mark mark (move-mark point insert-mark))
  832.          
  833.          ;; Redisplay is simple and efficient for most common case ---
  834.          ;; :north-west gravity, :left alignment, and insert/delete affecting only one line.
  835.          ;; Otherwise, redisplay is simple and inefficient! Replace with more
  836.          ;; sophisticated algorithm when possible.
  837.  
  838.          (multiple-value-bind (refresh-start refresh-end clear-p)
  839.              (if
  840.                (or (and (eq gravity :north-west) (eq alignment :left))
  841.                (and (eq gravity :north-east) (eq alignment :right)))
  842.             
  843.                ;; Optimize this case... 
  844.                (let*
  845.              ((one-line-p  (and small-delete-p
  846.                         (= (mark-line-index insert-mark)
  847.                            (mark-line-index insert-start))))
  848.               (ascent      (font-ascent font))
  849.               (descent     (font-descent font)) 
  850.               (clear-start (mark-line-index insert-start))
  851.               (line-height (+ ascent descent)))
  852.              
  853.              ;; Clear damaged areas. If multiple lines damaged, just clear to bottom of window.
  854.              (when (eq alignment :left)    
  855.                ;; This case can be optimized: clear first line only from insert point.
  856.                (text-clear-line
  857.                  text 
  858.                  (text-base-x text clear-start (mark-index insert-start))
  859.                  (text-base-y text clear-start)))
  860.              
  861.              (unless (and (eq alignment :left) one-line-p)
  862.                (when (eq alignment :left)
  863.                  ;; First line already cleared above.
  864.                  (incf clear-start))
  865.                
  866.                ;; Clear one or more lines. 
  867.                (clear-area
  868.                  text
  869.                  :x extent-left
  870.                  :y (- (text-base-y text clear-start) ascent)
  871.                  :width extent-width
  872.                  :height (when one-line-p line-height)))
  873.              
  874.              ;; If multiple lines damaged, just redisplay to end of buffer.
  875.              (values insert-start (if one-line-p insert-mark nil) t))
  876.            
  877.                ;; Else punt and redisplay everything!  Replace with more efficient
  878.                ;; algorithm when possible.
  879.                (progn
  880.              (clear-area text)
  881.              (values 0 nil nil)))
  882.            
  883.            (setf (text-extent-defined-p text) nil)
  884.            (text-refresh text refresh-start refresh-end clear-p)))))))))
  885.  
  886.     (defmethod text-insert ((text edit-text) (input character))
  887.       (edit-text-insert text input))
  888.  
  889.     (defmethod text-insert ((text edit-text) (input string))
  890.       (edit-text-insert text input))
  891.  
  892.     (defmethod text-insert-nongraphic ((text edit-text) (char (eql #\newline)))
  893.       (edit-text-insert text char))
  894.  
  895.     (defmethod text-insert-nongraphic ((text edit-text) (char (eql #\linefeed)))
  896.       (edit-text-insert text #\newline)))) 
  897.  
  898.  
  899. (let ((prev-point (make-mark)))
  900.   
  901.   (defmethod text-rubout ((text edit-text))
  902.     (with-slots (point mark gravity alignment buffer font extent-left extent-width) text
  903.       
  904.       (multiple-value-bind (initial-start initial-end) (text-selection-range text)
  905.     ;; Attempt to delete non-existent character?
  906.     (if
  907.       (and (not initial-start) (mark-equal point 0))
  908.  
  909.       ;; Yes, beep a warning.
  910.       (bell (contact-display text))
  911.       
  912.       ;; No, perform delete. 
  913.       (while-changing-marks (text)
  914.         (move-mark prev-point point)
  915.         
  916.         ;; Determine initial delete range.
  917.         (setf initial-start (or initial-start (buffer-move-mark buffer point :chars -1))
  918.           initial-end   (or initial-end prev-point))
  919.         
  920.         ;; Invoke :delete callback to determine actual delete range.
  921.         (multiple-value-bind (start end)
  922.         (apply-callback-else (text :delete text initial-start initial-end)
  923.           (values initial-start initial-end))
  924.           
  925.           ;; Deletion allowed?
  926.           (unless start (return-from text-rubout)) 
  927.           
  928.           ;; If delete range altered, then clear selection and do not delete it.
  929.           (unless (and (mark-equal start initial-start) (mark-equal end initial-end))
  930.         (setf (edit-text-mark text) point)) 
  931.           
  932.           ;; Clear damaged area, delete chars, then redisplay.
  933.           ;;
  934.           ;; Redisplay is simple and efficient for most common case ---
  935.           ;; :north-west gravity, :left alignment, and delete affecting only one line.
  936.           ;; Otherwise, redisplay is simple and inefficient! Replace with more
  937.           ;; sophisticated algorithm when possible.
  938.           
  939.           (let ((start (move-mark initial-start start))
  940.             (end   (move-mark initial-end end)))
  941.         
  942.         ;; Clear efficiently, if possible.
  943.         (multiple-value-bind (refresh-start refresh-end clear-p) 
  944.             (if
  945.               (or (and (eq gravity :north-west) (eq alignment :left))
  946.               (and (eq gravity :north-east) (eq alignment :right)))
  947.               
  948.               ;; Optimize this case... 
  949.               (let*
  950.             ((one-line-p  (= (mark-line-index start) (mark-line-index end)))
  951.              (ascent      (font-ascent font))
  952.              (descent     (font-descent font)) 
  953.              (clear-start (mark-line-index start))
  954.              (line-height (+ ascent descent)))
  955.             
  956.             ;; Clear damaged areas. If multiple lines damaged, just clear to bottom of window.
  957.             (when (eq alignment :left)    
  958.               ;; This case can be optimized: clear first line only from delete point.
  959.               (text-clear-line
  960.                 text 
  961.                 (text-base-x text clear-start (mark-index start))
  962.                 (text-base-y text clear-start)))
  963.             
  964.             (unless (and (eq alignment :left) one-line-p)
  965.               (when (eq alignment :left)
  966.                 ;; First line already cleared above.
  967.                 (incf clear-start))
  968.               
  969.               ;; Clear one or more lines. 
  970.               (clear-area
  971.                 text
  972.                 :x extent-left
  973.                 :y (- (text-base-y text clear-start) ascent)
  974.                 :width extent-width
  975.                 :height (when one-line-p line-height)))
  976.             
  977.             (values start (when one-line-p end) t))
  978.               
  979.               ;; Else punt and redisplay everything!  Replace with more efficient
  980.               ;; algorithm when possible.
  981.               (progn
  982.             (clear-area text)
  983.             (values 0 nil nil)))
  984.           
  985.           ;; Delete chars.
  986.           (buffer-delete buffer start end)
  987.           
  988.           ;; Redisplay buffer.
  989.           (setf (text-extent-defined-p text) nil)
  990.           (text-refresh text refresh-start refresh-end clear-p)) 
  991.         
  992.         ;; Update point and mark.
  993.         (move-mark point (move-mark mark start))))))))))
  994.  
  995.  
  996.  
  997.  
  998.  
  999.  
  1000.  
  1001.  
  1002.